home *** CD-ROM | disk | FTP | other *** search
/ io Programmo 37 / IOPROG_37.ISO / SOFT / Multilizer.exe / disk1 / data1.cab / data1 / [Group19]VCL Source Professional / IvDBMlCt.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1998-08-31  |  47.6 KB  |  1,866 lines
  1. unit IvDBMlCt;
  2.  
  3. {$I IVMULTI.INC}
  4.  
  5. interface
  6.  
  7. uses
  8. {$IFDEF WIN32}
  9.   Windows,
  10. {$ELSE}
  11.   WinTypes, WinProcs, DBLookup,
  12. {$ENDIF}
  13.   Messages, Forms, Graphics, Classes, Controls, DB, DBCtrls, IvMLCtrl;
  14.  
  15. type
  16.   TIvDBText = class(TDBText)
  17. {$IFNDEF IVBIDI}
  18.   private
  19.   {$IFDEF WIN32}
  20.     {$IFNDEF VER110}
  21.     procedure DoDrawText(var rect: TRect; flags: Integer);
  22.     {$ENDIF}
  23.   {$ENDIF}
  24.  
  25.   protected
  26.     FLocale: Integer;
  27.  
  28.     procedure SetLocale(value: Integer);
  29.  
  30.   {$IFDEF WIN32}
  31.     {$IFDEF VER110}
  32.     procedure DoDrawText(var rect: TRect; flags: Word); override;
  33.     {$ENDIF}
  34.     procedure Paint; override;
  35.   {$ENDIF}
  36.  
  37.   public
  38.     constructor Create(owner: TComponent); override;
  39.  
  40.   published
  41.     property Locale: Integer read FLocale write SetLocale stored False;
  42. {$ENDIF}
  43.   end;
  44.  
  45.   TIvDBRadioGroup = class(TDBRadioGroup)
  46. {$IFNDEF IVBIDI}
  47.   protected
  48.     FLocale: Integer;
  49.  
  50.     procedure SetLocale(value: Integer);
  51.  
  52.   {$IFDEF WIN32}
  53.     procedure Paint; override;
  54.   {$ENDIF}
  55.  
  56.   public
  57.     constructor Create(owner: TComponent); override;
  58.  
  59.   published
  60.     property Locale: Integer read FLocale write SetLocale stored False;
  61. {$ENDIF}
  62.   end;
  63.  
  64.   TIvDBListBox = class(TDBListBox)
  65. {$IFNDEF IVBIDI}
  66.   private
  67.     FLocale: Integer;
  68.  
  69.     procedure SetLocale(value: Integer);
  70.  
  71.   protected
  72.     procedure CreateParams(var Params: TCreateParams); override;
  73.  
  74.   public
  75.     constructor Create(owner: TComponent); override;
  76.  
  77.   published
  78.     property Locale: Integer read FLocale write SetLocale stored False;
  79. {$ENDIF}
  80.   end;
  81.  
  82.   TIvDBComboBox = class(TDBComboBox)
  83. {$IFNDEF IVBIDI}
  84.   private
  85.     FLocale: Integer;
  86.  
  87.     procedure SetLocale(value: Integer);
  88.  
  89.   protected
  90.     procedure CreateParams(var Params: TCreateParams); override;
  91.  
  92.   public
  93.     constructor Create(owner: TComponent); override;
  94.  
  95.   published
  96.     property Locale: Integer read FLocale write SetLocale stored False;
  97. {$ENDIF}
  98.   end;
  99.  
  100. {$IFDEF WIN32}
  101. {$IFDEF IVBIDI}
  102.   TIvDBLookupControl = class(TDBLookupControl)
  103.   end;
  104. {$ELSE}
  105.   TIvDBLookupControl = class;
  106.  
  107.   TIvDataSourceLink = class(TDataLink)
  108.   private
  109.     FDBLookupControl: TIvDBLookupControl;
  110.  
  111.   protected
  112.     procedure FocusControl(Field: TFieldRef); override;
  113.     procedure ActiveChanged; override;
  114.     procedure RecordChanged(Field: TField); override;
  115.   end;
  116.  
  117.   TIvListSourceLink = class(TDataLink)
  118.   private
  119.     FDBLookupControl: TIvDBLookupControl;
  120.  
  121.   protected
  122.     procedure ActiveChanged; override;
  123.     procedure DataSetChanged; override;
  124.   end;
  125.  
  126.   TIvDBLookupControl = class(TCustomControl)
  127.   private
  128.     FLocale: Integer;
  129.     FLookupSource: TDataSource;
  130.     FDataLink: TIvDataSourceLink;
  131.     FListLink: TIvListSourceLink;
  132.     FDataFieldName: string;
  133.     FKeyFieldName: string;
  134.     FListFieldName: string;
  135.     FListFieldIndex: Integer;
  136.     FDataField: TField;
  137.     FMasterField: TField;
  138.     FKeyField: TField;
  139.     FListField: TField;
  140.     FListFields: TList;
  141.     FKeyValue: Variant;
  142.     FSearchText: string;
  143.     FLookupMode: Boolean;
  144.     FListActive: Boolean;
  145.     FFocused: Boolean;
  146.  
  147.     procedure SetLocale(value: Integer);
  148.     function CanModify: Boolean;
  149.     procedure CheckNotCircular;
  150.     procedure CheckNotLookup;
  151.     procedure DataLinkActiveChanged;
  152.     procedure DataLinkRecordChanged(Field: TField);
  153.     function GetBorderSize: Integer;
  154.     function GetDataSource: TDataSource;
  155.     function GetKeyFieldName: string;
  156.     function GetListSource: TDataSource;
  157.     function GetReadOnly: Boolean;
  158.     function GetTextHeight: Integer;
  159.     procedure KeyValueChanged; virtual;
  160.     procedure ListLinkActiveChanged; virtual;
  161.     procedure ListLinkDataChanged; virtual;
  162.     function LocateKey: Boolean;
  163.     procedure ProcessSearchKey(Key: Char);
  164.     procedure SelectKeyValue(const Value: Variant);
  165.     procedure SetDataFieldName(const Value: string);
  166.     procedure SetDataSource(Value: TDataSource);
  167.     procedure SetKeyFieldName(const Value: string);
  168.     procedure SetKeyValue(const Value: Variant);
  169.     procedure SetListFieldName(const Value: string);
  170.     procedure SetListSource(Value: TDataSource);
  171.     procedure SetLookupMode(Value: Boolean);
  172.     procedure SetReadOnly(Value: Boolean);
  173.     procedure WMGetDlgCode(var Message: TMessage); message WM_GETDLGCODE;
  174.     procedure WMKillFocus(var Message: TMessage); message WM_KILLFOCUS;
  175.     procedure WMSetFocus(var Message: TMessage); message WM_SETFOCUS;
  176.  
  177.   protected
  178.     procedure Notification(AComponent: TComponent;
  179.       Operation: TOperation); override;
  180.     property DataField: string read FDataFieldName write SetDataFieldName;
  181.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  182.     property KeyField: string read GetKeyFieldName write SetKeyFieldName;
  183.     property KeyValue: Variant read FKeyValue write SetKeyValue;
  184.     property ListField: string read FListFieldName write SetListFieldName;
  185.     property ListFieldIndex: Integer read FListFieldIndex write FListFieldIndex default 0;
  186.     property ListSource: TDataSource read GetListSource write SetListSource;
  187.     property ParentColor default False;
  188.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  189.     property TabStop default True;
  190.  
  191.     procedure PaintItem(Canvas: TCanvas; const str: String; rect: TRect; x, y: Integer);
  192.  
  193.   public
  194.     constructor Create(AOwner: TComponent); override;
  195.     destructor Destroy; override;
  196.     property Field: TField read FDataField;
  197.  
  198.   published
  199.     property Locale: Integer read FLocale write SetLocale stored False;
  200.   end;
  201. {$ENDIF}
  202.  
  203. {$IFDEF IVBIDI}
  204.   TIvDBLookupListBox = class(TDBLookupListBox)
  205.   end;
  206. {$ELSE}
  207.   TIvDBLookupListBox = class(TIvDBLookupControl)
  208.   private
  209.     FRecordIndex: Integer;
  210.     FRecordCount: Integer;
  211.     FRowCount: Integer;
  212.     FBorderStyle: TBorderStyle;
  213.     FPopup: Boolean;
  214.     FKeySelected: Boolean;
  215.     FTracking: Boolean;
  216.     FTimerActive: Boolean;
  217.     FLockPosition: Boolean;
  218.     FMousePos: Integer;
  219.     FSelectedItem: string;
  220.  
  221.     function GetKeyIndex: Integer;
  222.     procedure KeyValueChanged; override;
  223.     procedure ListLinkActiveChanged; override;
  224.     procedure ListLinkDataChanged; override;
  225.     procedure SelectCurrent;
  226.     procedure SelectItemAt(X, Y: Integer);
  227.     procedure SetBorderStyle(Value: TBorderStyle);
  228.     procedure SetRowCount(Value: Integer);
  229.     procedure StopTimer;
  230.     procedure StopTracking;
  231.     procedure TimerScroll;
  232.     procedure UpdateScrollBar;
  233.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  234.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  235.     procedure WMCancelMode(var Message: TMessage); message WM_CANCELMODE;
  236.     procedure WMTimer(var Message: TMessage); message WM_TIMER;
  237.     procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
  238.  
  239.   protected
  240.     procedure CreateParams(var Params: TCreateParams); override;
  241.     procedure CreateWnd; override;
  242.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  243.     procedure KeyPress(var Key: Char); override;
  244.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  245.       X, Y: Integer); override;
  246.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  247.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  248.       X, Y: Integer); override;
  249.     procedure Paint; override;
  250.     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  251.  
  252.   public
  253.     constructor Create(owner: TComponent); override;
  254.  
  255.     property KeyValue;
  256.     property SelectedItem: string read FSelectedItem;
  257.  
  258.   published
  259.     property Align;
  260.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  261.     property Color;
  262.     property Ctl3D;
  263.     property DataField;
  264.     property DataSource;
  265.     property DragCursor;
  266.     property DragMode;
  267.     property Enabled;
  268.     property Font;
  269. {$IFDEF IVWIDE}
  270.     property ImeMode;
  271.     property ImeName;
  272. {$ENDIF}
  273.     property KeyField;
  274.     property ListField;
  275.     property ListFieldIndex;
  276.     property ListSource;
  277.     property ParentColor;
  278.     property ParentCtl3D;
  279.     property ParentFont;
  280.     property ParentShowHint;
  281.     property PopupMenu;
  282.     property ReadOnly;
  283.     property RowCount: Integer read FRowCount write SetRowCount stored False;
  284.     property ShowHint;
  285.     property TabOrder;
  286.     property TabStop;
  287.     property Visible;
  288.     property OnClick;
  289.     property OnDblClick;
  290.     property OnDragDrop;
  291.     property OnDragOver;
  292.     property OnEndDrag;
  293.     property OnEnter;
  294.     property OnExit;
  295.     property OnKeyDown;
  296.     property OnKeyPress;
  297.     property OnKeyUp;
  298.     property OnMouseDown;
  299.     property OnMouseMove;
  300.     property OnMouseUp;
  301.     property OnStartDrag;
  302.   end;
  303. {$ENDIF}
  304.  
  305. {$IFDEF IVBIDI}
  306.   TIvDBLookupComboBox = class(TDBLookupComboBox)
  307.   end;
  308. {$ELSE}
  309.   TIvPopupDataList = class(TIvDBLookupListBox)
  310.   private
  311.     procedure WMMouseActivate(var Message: TMessage); message WM_MOUSEACTIVATE;
  312.   protected
  313.     procedure CreateParams(var Params: TCreateParams); override;
  314.   public
  315.     constructor Create(AOwner: TComponent); override;
  316.   end;
  317.  
  318.   TIvDropDownAlign = (daLeft, daRight, daCenter);
  319.  
  320.   TIvDBLookupComboBox = class(TIvDBLookupControl)
  321.   private
  322.     FDataList: TIvPopupDataList;
  323.     FButtonWidth: Integer;
  324.     FText: string;
  325.     FDropDownRows: Integer;
  326.     FDropDownWidth: Integer;
  327.     FDropDownAlign: TIvDropDownAlign;
  328.     FListVisible: Boolean;
  329.     FPressed: Boolean;
  330.     FTracking: Boolean;
  331.     FAlignment: TAlignment;
  332.     FLookupMode: Boolean;
  333.     FOnDropDown: TNotifyEvent;
  334.     FOnCloseUp: TNotifyEvent;
  335.  
  336.     procedure KeyValueChanged; override;
  337.     procedure ListLinkActiveChanged; override;
  338.     procedure ListMouseUp(Sender: TObject; Button: TMouseButton;
  339.       Shift: TShiftState; X, Y: Integer);
  340.     procedure StopTracking;
  341.     procedure TrackButton(X, Y: Integer);
  342.     procedure CMCancelMode(var Message: TCMCancelMode); message CM_CANCELMODE;
  343.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  344.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  345.     procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
  346.     procedure WMCancelMode(var Message: TMessage); message WM_CANCELMODE;
  347.     procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
  348.  
  349.   protected
  350.     procedure CreateParams(var Params: TCreateParams); override;
  351.     procedure Paint; override;
  352.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  353.     procedure KeyPress(var Key: Char); override;
  354.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  355.       X, Y: Integer); override;
  356.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  357.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  358.       X, Y: Integer); override;
  359.     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  360.  
  361.   public
  362.     constructor Create(AOwner: TComponent); override;
  363.  
  364.     procedure CloseUp(Accept: Boolean);
  365.     procedure DropDown;
  366.  
  367.     property KeyValue;
  368.     property ListVisible: Boolean read FListVisible;
  369.     property Text: string read FText;
  370.  
  371.   published
  372.     property Color;
  373.     property Ctl3D;
  374.     property DataField;
  375.     property DataSource;
  376.     property DragCursor;
  377.     property DragMode;
  378.     property DropDownAlign: TIvDropDownAlign read FDropDownAlign write FDropDownAlign default daLeft;
  379.     property DropDownRows: Integer read FDropDownRows write FDropDownRows default 7;
  380.     property DropDownWidth: Integer read FDropDownWidth write FDropDownWidth default 0;
  381.     property Enabled;
  382.     property Font;
  383. {$IFDEF IVWIDE}
  384.     property ImeMode;
  385.     property ImeName;
  386. {$ENDIF}
  387.     property KeyField;
  388.     property ListField;
  389.     property ListFieldIndex;
  390.     property ListSource;
  391.     property ParentColor;
  392.     property ParentCtl3D;
  393.     property ParentFont;
  394.     property ParentShowHint;
  395.     property PopupMenu;
  396.     property ReadOnly;
  397.     property ShowHint;
  398.     property TabOrder;
  399.     property TabStop;
  400.     property Visible;
  401.     property OnClick;
  402.     property OnCloseUp: TNotifyEvent read FOnCloseUp write FOnCloseUp;
  403.     property OnDragDrop;
  404.     property OnDragOver;
  405.     property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;
  406.     property OnEndDrag;
  407.     property OnEnter;
  408.     property OnExit;
  409.     property OnKeyDown;
  410.     property OnKeyPress;
  411.     property OnKeyUp;
  412.     property OnMouseDown;
  413.     property OnMouseMove;
  414.     property OnMouseUp;
  415.     property OnStartDrag;
  416.   end;
  417. {$ENDIF}
  418. {$ELSE}
  419.   TIvDBLookupListBox = class(TDBLookupList)
  420.   end;
  421.  
  422.   TIvDBLookupComboBox = class(TDBLookupCombo)
  423.   end;
  424. {$ENDIF}
  425.  
  426. implementation
  427.  
  428. {$IFNDEF IVBIDI}
  429. uses
  430.   SysUtils,
  431.   DBConsts, IvDictio, IvMulti;
  432.  
  433. { TIvDBText }
  434.  
  435. constructor TIvDBText.Create(owner: TComponent);
  436. begin
  437.   inherited Create(owner);
  438.   FLocale := 0;
  439. end;
  440.  
  441. procedure TIvDBText.SetLocale(value: Integer);
  442. begin
  443.   if value <> FLocale then
  444.   begin
  445.     FLocale := value;
  446.     Invalidate;
  447.   end;
  448. end;
  449.  
  450. {$IFDEF WIN32}
  451.   {$IFDEF VER110}
  452. procedure TIvDBText.DoDrawText(var rect: TRect; flags: Word);
  453.   {$ELSE}
  454. procedure TIvDBText.DoDrawText(var rect: TRect; flags: Integer);
  455.   {$ENDIF}
  456. var
  457.   Text: String;
  458. begin
  459.   Text := GetLabelText;
  460.   if (Flags and DT_CALCRECT <> 0) and ((Text = '') or ShowAccelChar and
  461.     (Text[1] = '&') and (Text[2] = #0)) then Text := Text + ' ';
  462.   if not ShowAccelChar then
  463.     Flags := Flags or DT_NOPREFIX;
  464.   Canvas.Font := Font;
  465.  
  466. {$IFDEF IVPRO32}
  467.  if IvIsLocaleBidirectional(FLocale) then
  468.    Flags := Flags or DT_RTLREADING;
  469. {$ENDIF}
  470.  
  471. {$IFDEF IVWIDE}
  472.   if not Enabled then
  473.   begin
  474.     OffsetRect(Rect, 1, 1);
  475.     Canvas.Font.Color := clBtnHighlight;
  476.     DrawTextEx(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags, nil);
  477.     OffsetRect(Rect, -1, -1);
  478.     Canvas.Font.Color := clBtnShadow;
  479.     DrawTextEx(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags, nil);
  480.   end
  481.   else
  482.     DrawTextEx(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags, nil);
  483. {$ELSE}
  484.   if not Enabled then
  485.     Canvas.Font.Color := clGrayText;
  486.   DrawTextEx(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags, nil);
  487. {$ENDIF}
  488. end;
  489.  
  490. procedure TIvDBText.Paint;
  491. const
  492.   Alignments: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
  493.   BidiAlignments: array[TAlignment] of Word = (DT_RIGHT, DT_LEFT, DT_CENTER);
  494.   WordWraps: array[Boolean] of Word = (0, DT_WORDBREAK);
  495. var
  496.   Rect: TRect;
  497.   DrawStyle: Integer;
  498. begin
  499.   with Canvas do
  500.   begin
  501.     if not Transparent then
  502.     begin
  503.       Brush.Color := Self.Color;
  504.       Brush.Style := bsSolid;
  505.       FillRect(ClientRect);
  506.     end;
  507.     Brush.Style := bsClear;
  508.     Rect := ClientRect;
  509.     DrawStyle := DT_EXPANDTABS or WordWraps[WordWrap];
  510. {$IFDEF IVPRO32}
  511.     if IvIsLocaleBidirectional(FLocale) then
  512.       DrawStyle := DrawStyle or BidiAlignments[Alignment]
  513.     else
  514. {$ENDIF}
  515.       DrawStyle := DrawStyle or Alignments[Alignment];
  516.     DoDrawText(Rect, DrawStyle);
  517.   end;
  518. end;
  519. {$ENDIF}
  520.  
  521.  
  522. { TIvDBRadioGroup }
  523.  
  524. constructor TIvDBRadioGroup.Create(owner: TComponent);
  525. begin
  526.   inherited Create(owner);
  527.   FLocale := 0;
  528. end;
  529.  
  530. procedure TIvDBRadioGroup.SetLocale(value: Integer);
  531. begin
  532.   if FLocale <> Value then
  533.   begin
  534.     FLocale := Value;
  535.     Invalidate;
  536.   end;
  537. end;
  538.  
  539. {$IFDEF WIN32}
  540. procedure TIvDBRadioGroup.Paint;
  541. var
  542. {$IFDEF IVPRO32}
  543.   w: Integer;
  544. {$ENDIF}
  545.   H: Integer;
  546.   R: TRect;
  547. begin
  548.   with Canvas do
  549.   begin
  550.     Font := Self.Font;
  551.     H := TextHeight('0');
  552.     R := Rect(0, H div 2 - 1, Width, Height);
  553.     if Ctl3D then
  554.     begin
  555.       Inc(R.Left);
  556.       Inc(R.Top);
  557.       Brush.Color := clBtnHighlight;
  558.       FrameRect(R);
  559.       OffsetRect(R, -1, -1);
  560.       Brush.Color := clBtnShadow;
  561.     end else
  562.       Brush.Color := clWindowFrame;
  563.     FrameRect(R);
  564.     if Text <> '' then
  565.     begin
  566.       R := Rect(8, 0, Width - 16, H);
  567.       DrawText(
  568.         Handle,
  569.         PChar(Text),
  570.         Length(Text),
  571.         R,
  572.         DT_LEFT or DT_SINGLELINE or DT_CALCRECT);
  573.       Brush.Color := Color;
  574. {$IFDEF IVPRO32}
  575.       w := R.right - R.left;
  576.       if IvIsLocaleBidirectional(FLocale) then
  577.       begin
  578.         R.right := Width - 8;
  579.         R.left := R.right - w;
  580.       end;
  581. {$ENDIF}
  582.  
  583.       DrawText(
  584.         Handle,
  585.         PChar(Text),
  586.         Length(Text),
  587.         R,
  588.         DT_LEFT or DT_SINGLELINE);
  589.     end;
  590.   end;
  591. end;
  592. {$ENDIF}
  593.  
  594. { TIvDBListBox }
  595.  
  596. constructor TIvDBListBox.Create(owner: TComponent);
  597. begin
  598.   inherited Create(owner);
  599.   FLocale := 0;
  600. end;
  601.  
  602. procedure TIvDBListBox.SetLocale(value: Integer);
  603. begin
  604.   if value <> FLocale then
  605.   begin
  606.     FLocale := value;
  607. {$IFDEF IVPRO32}
  608.     RecreateWnd;
  609. {$ENDIF}
  610.   end;
  611. end;
  612.  
  613. procedure TIvDBListBox.CreateParams(var Params: TCreateParams);
  614. begin
  615.   inherited CreateParams(params);
  616. {$IFDEF IVPRO32}
  617.   if IvIsLocaleBidirectional(FLocale) then
  618.     Params.ExStyle := Params.ExStyle or WS_EX_RIGHT or WS_EX_LEFTSCROLLBAR or WS_EX_RTLREADING;
  619. {$ENDIF}
  620. end;
  621.  
  622.  
  623. { TIvDBComboBox }
  624.  
  625. constructor TIvDBComboBox.Create(owner: TComponent);
  626. begin
  627.   inherited Create(owner);
  628.   FLocale := 0;
  629. end;
  630.  
  631. procedure TIvDBComboBox.SetLocale(value: Integer);
  632. begin
  633.   if value <> FLocale then
  634.   begin
  635.     FLocale := value;
  636. {$IFDEF IVPRO32}
  637.     RecreateWnd;
  638. {$ENDIF}
  639.   end;
  640. end;
  641.  
  642. procedure TIvDBComboBox.CreateParams(var Params: TCreateParams);
  643. begin
  644.   inherited CreateParams(params);
  645. {$IFDEF IVPRO32}
  646.   if IvIsLocaleBidirectional(FLocale) then
  647.     Params.ExStyle := Params.ExStyle or WS_EX_RIGHT or WS_EX_LEFTSCROLLBAR or WS_EX_RTLREADING;
  648. {$ENDIF}
  649. end;
  650.  
  651.  
  652. {$IFDEF WIN32}
  653. { TIvDataSourceLink }
  654.  
  655. procedure TIvDataSourceLink.ActiveChanged;
  656. begin
  657.   if FDBLookupControl <> nil then
  658.     FDBLookupControl.DataLinkActiveChanged;
  659. end;
  660.  
  661. procedure TIvDataSourceLink.RecordChanged(Field: TField);
  662. begin
  663.   if FDBLookupControl <> nil then
  664.     FDBLookupControl.DataLinkRecordChanged(Field);
  665. end;
  666.  
  667. procedure TIvDataSourceLink.FocusControl(Field: TFieldRef);
  668. begin
  669.   if (Field^ <> nil) and (Field^ = FDBLookupControl.Field) and
  670.     (FDBLookupControl <> nil) and FDBLookupControl.CanFocus then
  671.   begin
  672.     Field^ := nil;
  673.     FDBLookupControl.SetFocus;
  674.   end;
  675. end;
  676.  
  677.  
  678. { TIvListSourceLink }
  679.  
  680. procedure TIvListSourceLink.ActiveChanged;
  681. begin
  682.   if FDBLookupControl <> nil then
  683.     FDBLookupControl.ListLinkActiveChanged;
  684. end;
  685.  
  686. procedure TIvListSourceLink.DataSetChanged;
  687. begin
  688.   if FDBLookupControl <> nil then
  689.     FDBLookupControl.ListLinkDataChanged;
  690. end;
  691.  
  692.  
  693. { TIvDBLookupControl }
  694.  
  695. function VarEquals(const V1, V2: Variant): Boolean;
  696. begin
  697.   Result := False;
  698.   try
  699.     Result := V1 = V2;
  700.   except
  701.   end;
  702. end;
  703.  
  704. var
  705.   SearchTickCount: Integer = 0;
  706.  
  707. constructor TIvDBLookupControl.Create(AOwner: TComponent);
  708. begin
  709.   inherited Create(AOwner);
  710.   FLocale := 0;
  711.   if NewStyleControls then
  712.     ControlStyle := [csOpaque] else
  713.     ControlStyle := [csOpaque, csFramed];
  714.   ParentColor := False;
  715.   TabStop := True;
  716.   FLookupSource := TDataSource.Create(Self);
  717.   FDataLink := TIvDataSourceLink.Create;
  718.   FDataLink.FDBLookupControl := Self;
  719.   FListLink := TIvListSourceLink.Create;
  720.   FListLink.FDBLookupControl := Self;
  721.   FListFields := TList.Create;
  722.   FKeyValue := Null;
  723. end;
  724.  
  725. destructor TIvDBLookupControl.Destroy;
  726. begin
  727.   FListFields.Free;
  728.   FListLink.FDBLookupControl := nil;
  729.   FListLink.Free;
  730.   FDataLink.FDBLookupControl := nil;
  731.   FDataLink.Free;
  732.   inherited Destroy;
  733. end;
  734.  
  735. procedure TIvDBLookupControl.PaintItem(
  736.   Canvas: TCanvas;
  737.   const str: String;
  738.   rect: TRect;
  739.   x, y: Integer);
  740. var
  741.   flags: Integer;
  742. begin
  743. {$IFDEF IVPRO32}
  744.   if IvIsLocaleBidirectional(FLocale) then
  745.     Flags := DT_RIGHT + DT_RTLREADING
  746.   else
  747. {$ENDIF}
  748.     Flags := DT_LEFT;
  749.   Canvas.Pen.Style := psClear;
  750.   Canvas.Rectangle(rect.Left, rect.Top, rect.Right + 1, rect.Bottom + 1);
  751.   Inc(rect.Left, x);
  752.   Inc(rect.Top, y);
  753.   DrawTextEx(Canvas.Handle, PChar(str), Length(str), rect, flags, nil);
  754. end;
  755.  
  756. procedure TIvDBLookupControl.SetLocale(value: Integer);
  757. begin
  758.   if value <> FLocale then
  759.   begin
  760.     FLocale := value;
  761. {$IFDEF IVPRO32}
  762.     RecreateWnd;
  763. {$ENDIF}
  764.   end;
  765. end;
  766.  
  767. function TIvDBLookupControl.CanModify: Boolean;
  768. begin
  769.   Result := FListActive and not ReadOnly and ((FDataLink.DataSource = nil) or
  770.     (FMasterField <> nil) and FMasterField.CanModify);
  771. end;
  772.  
  773. procedure TIvDBLookupControl.CheckNotCircular;
  774. begin
  775.   if FDataLink.Active and FDataLink.DataSet.IsLinkedTo(ListSource) then
  776. {$IFDEF IVWIDE}
  777.     DatabaseError(SCircularDataLink);
  778. {$ELSE}
  779.     DatabaseError(LoadStr(SCircularDataLink));
  780. {$ENDIF}
  781.   if FListLink.Active and FListLink.DataSet.IsLinkedTo(DataSource) then
  782. {$IFDEF IVWIDE}
  783.     DatabaseError(SCircularDataLink);
  784. {$ELSE}
  785.     DatabaseError(LoadStr(SCircularDataLink));
  786. {$ENDIF}
  787. end;
  788.  
  789. procedure TIvDBLookupControl.CheckNotLookup;
  790. begin
  791.   if FLookupMode then
  792. {$IFDEF IVWIDE}
  793.     DatabaseError(SPropDefByLookup);
  794. {$ELSE}
  795.     DatabaseError(LoadStr(SPropDefByLookup));
  796. {$ENDIF}
  797.   if FDataLink.DataSourceFixed then
  798. {$IFDEF IVWIDE}
  799.     DatabaseError(SDataSourceFixed);
  800. {$ELSE}
  801.     DatabaseError(LoadStr(SPropDefByLookup));
  802. {$ENDIF}
  803. end;
  804.  
  805. procedure TIvDBLookupControl.DataLinkActiveChanged;
  806. begin
  807.   FDataField := nil;
  808.   FMasterField := nil;
  809.   if FDataLink.Active and (FDataFieldName <> '') then
  810.   begin
  811.     CheckNotCircular;
  812. {$IFDEF IVWIDE}
  813.     FDataField := GetFieldProperty(FDataLink.DataSet, Self, FDataFieldName);
  814. {$ELSE}
  815.     FDataField := FDataLink.DataSet.FieldByName(FDataFieldName);
  816. {$ENDIF}
  817.     FMasterField := FDataField;
  818.   end;
  819.   SetLookupMode((FDataField <> nil) and (FDataField.FieldKind = fkLookup));
  820.   DataLinkRecordChanged(nil);
  821. end;
  822.  
  823. procedure TIvDBLookupControl.DataLinkRecordChanged(Field: TField);
  824. begin
  825.   if (Field = nil) or (Field = FMasterField) then
  826.     if FMasterField <> nil then
  827.       SetKeyValue(FMasterField.Value) else
  828.       SetKeyValue(Null);
  829. end;
  830.  
  831. function TIvDBLookupControl.GetBorderSize: Integer;
  832. var
  833.   Params: TCreateParams;
  834.   R: TRect;
  835. begin
  836.   CreateParams(Params);
  837.   SetRect(R, 0, 0, 0, 0);
  838.   AdjustWindowRectEx(R, Params.Style, False, Params.ExStyle);
  839.   Result := R.Bottom - R.Top;
  840. end;
  841.  
  842. function TIvDBLookupControl.GetDataSource: TDataSource;
  843. begin
  844.   Result := FDataLink.DataSource;
  845. end;
  846.  
  847. function TIvDBLookupControl.GetKeyFieldName: string;
  848. begin
  849.   if FLookupMode then Result := '' else Result := FKeyFieldName;
  850. end;
  851.  
  852. function TIvDBLookupControl.GetListSource: TDataSource;
  853. begin
  854.   if FLookupMode then Result := nil else Result := FListLink.DataSource;
  855. end;
  856.  
  857. function TIvDBLookupControl.GetReadOnly: Boolean;
  858. begin
  859.   Result := FDataLink.ReadOnly;
  860. end;
  861.  
  862. function TIvDBLookupControl.GetTextHeight: Integer;
  863. var
  864.   DC: HDC;
  865.   SaveFont: HFont;
  866.   Metrics: TTextMetric;
  867. begin
  868.   DC := GetDC(0);
  869.   SaveFont := SelectObject(DC, Font.Handle);
  870.   GetTextMetrics(DC, Metrics);
  871.   SelectObject(DC, SaveFont);
  872.   ReleaseDC(0, DC);
  873.   Result := Metrics.tmHeight;
  874. end;
  875.  
  876. procedure TIvDBLookupControl.KeyValueChanged;
  877. begin
  878. end;
  879.  
  880. procedure TIvDBLookupControl.ListLinkActiveChanged;
  881. var
  882.   DataSet: TDataSet;
  883.   ResultField: TField;
  884. begin
  885.   FListActive := False;
  886.   FKeyField := nil;
  887.   FListField := nil;
  888.   FListFields.Clear;
  889.   if FListLink.Active and (FKeyFieldName <> '') then
  890.   begin
  891.     CheckNotCircular;
  892.     DataSet := FListLink.DataSet;
  893. {$IFDEF IVWIDE}
  894.     FKeyField := GetFieldProperty(DataSet, Self, FKeyFieldName);
  895. {$ELSE}
  896.     FKeyField := DataSet.FieldByName(FKeyFieldName);
  897. {$ENDIF}
  898.     try
  899.       DataSet.GetFieldList(FListFields, FListFieldName);
  900.     except
  901. {$IFDEF IVWIDE}
  902.       DatabaseErrorFmt(SFieldNotFound, [Self.Name, FListFieldName]);
  903. {$ENDIF}
  904.     end;
  905.     if FLookupMode then
  906.     begin
  907. {$IFDEF IVWIDE}
  908.       ResultField := GetFieldProperty(DataSet, Self, FDataField.LookupResultField);
  909. {$ELSE}
  910.       ResultField := DataSet.FieldByName(FDataField.LookupResultField);
  911. {$ENDIF}
  912.       if FListFields.IndexOf(ResultField) < 0 then
  913.         FListFields.Insert(0, ResultField);
  914.       FListField := ResultField;
  915.     end else
  916.     begin
  917.       if FListFields.Count = 0 then FListFields.Add(FKeyField);
  918.       if (FListFieldIndex >= 0) and (FListFieldIndex < FListFields.Count) then
  919.         FListField := FListFields[FListFieldIndex] else
  920.         FListField := FListFields[0];
  921.     end;
  922.     FListActive := True;
  923.   end;
  924. end;
  925.  
  926. procedure TIvDBLookupControl.ListLinkDataChanged;
  927. begin
  928. end;
  929.  
  930. function TIvDBLookupControl.LocateKey: Boolean;
  931. begin
  932.   Result := False;
  933.   try
  934.     if not VarIsNull(FKeyValue) and
  935.       FListLink.DataSet.Locate(FKeyFieldName, FKeyValue, []) then
  936.       Result := True;
  937.   except
  938.   end;
  939. end;
  940.  
  941. procedure TIvDBLookupControl.Notification(AComponent: TComponent;
  942.   Operation: TOperation);
  943. begin
  944.   inherited Notification(AComponent, Operation);
  945.   if Operation = opRemove then
  946.   begin
  947.     if (FDataLink <> nil) and (AComponent = DataSource) then DataSource := nil;
  948.     if (FListLink <> nil) and (AComponent = ListSource) then ListSource := nil;
  949.   end;
  950. end;
  951.  
  952. procedure TIvDBLookupControl.ProcessSearchKey(Key: Char);
  953. var
  954.   TickCount: Integer;
  955.   S: string;
  956. begin
  957.   if (FListField <> nil) and (FListField.FieldKind = fkData) and
  958.     (FListField.DataType = ftString) then
  959.     case Key of
  960.       #8, #27: FSearchText := '';
  961.       #32..#255:
  962.         if CanModify then
  963.         begin
  964.           TickCount := GetTickCount;
  965.           if TickCount - SearchTickCount > 2000 then FSearchText := '';
  966.           SearchTickCount := TickCount;
  967.           if Length(FSearchText) < 32 then
  968.           begin
  969.             S := FSearchText + Key;
  970.             if FListLink.DataSet.Locate(FListField.FieldName, S,
  971.               [loCaseInsensitive, loPartialKey]) then
  972.             begin
  973.               SelectKeyValue(FKeyField.Value);
  974.               FSearchText := S;
  975.             end;
  976.           end;
  977.         end;
  978.     end;
  979. end;
  980.  
  981. procedure TIvDBLookupControl.SelectKeyValue(const Value: Variant);
  982. begin
  983.   if FMasterField <> nil then
  984.   begin
  985.     if FDataLink.Edit then
  986.       FMasterField.Value := Value;
  987.   end else
  988.     SetKeyValue(Value);
  989.   Repaint;
  990.   Click;
  991. end;
  992.  
  993. procedure TIvDBLookupControl.SetDataFieldName(const Value: string);
  994. begin
  995.   if FDataFieldName <> Value then
  996.   begin
  997.     FDataFieldName := Value;
  998.     DataLinkActiveChanged;
  999.   end;
  1000. end;
  1001.  
  1002. procedure TIvDBLookupControl.SetDataSource(Value: TDataSource);
  1003. begin
  1004.   FDataLink.DataSource := Value;
  1005.   if Value <> nil then Value.FreeNotification(Self);
  1006. end;
  1007.  
  1008. procedure TIvDBLookupControl.SetKeyFieldName(const Value: string);
  1009. begin
  1010.   CheckNotLookup;
  1011.   if FKeyFieldName <> Value then
  1012.   begin
  1013.     FKeyFieldName := Value;
  1014.     ListLinkActiveChanged;
  1015.   end;
  1016. end;
  1017.  
  1018. procedure TIvDBLookupControl.SetKeyValue(const Value: Variant);
  1019. begin
  1020.   if not VarEquals(FKeyValue, Value) then
  1021.   begin
  1022.     FKeyValue := Value;
  1023.     KeyValueChanged;
  1024.   end;
  1025. end;
  1026.  
  1027. procedure TIvDBLookupControl.SetListFieldName(const Value: string);
  1028. begin
  1029.   if FListFieldName <> Value then
  1030.   begin
  1031.     FListFieldName := Value;
  1032.     ListLinkActiveChanged;
  1033.   end;
  1034. end;
  1035.  
  1036. procedure TIvDBLookupControl.SetListSource(Value: TDataSource);
  1037. begin
  1038.   CheckNotLookup;
  1039.   FListLink.DataSource := Value;
  1040.   if Value <> nil then Value.FreeNotification(Self);
  1041. end;
  1042.  
  1043. procedure TIvDBLookupControl.SetLookupMode(Value: Boolean);
  1044. begin
  1045.   if FLookupMode <> Value then
  1046.     if Value then
  1047.     begin
  1048. {$IFDEF IVWIDE}
  1049.       FMasterField := GetFieldProperty(FDataField.DataSet, Self, FDataField.KeyFields);
  1050. {$ELSE}
  1051.       FMasterField := FDataField.DataSet.FieldByName(FDataField.KeyFields);
  1052. {$ENDIF}
  1053.       FLookupSource.DataSet := FDataField.LookupDataSet;
  1054.       FKeyFieldName := FDataField.LookupKeyFields;
  1055.       FLookupMode := True;
  1056.       FListLink.DataSource := FLookupSource;
  1057.     end else
  1058.     begin
  1059.       FListLink.DataSource := nil;
  1060.       FLookupMode := False;
  1061.       FKeyFieldName := '';
  1062.       FLookupSource.DataSet := nil;
  1063.       FMasterField := FDataField;
  1064.     end;
  1065. end;
  1066.  
  1067. procedure TIvDBLookupControl.SetReadOnly(Value: Boolean);
  1068. begin
  1069.   FDataLink.ReadOnly := Value;
  1070. end;
  1071.  
  1072. procedure TIvDBLookupControl.WMGetDlgCode(var Message: TMessage);
  1073. begin
  1074.   Message.Result := DLGC_WANTARROWS or DLGC_WANTCHARS;
  1075. end;
  1076.  
  1077. procedure TIvDBLookupControl.WMKillFocus(var Message: TMessage);
  1078. begin
  1079.   FFocused := False;
  1080.   Inherited;
  1081.   Invalidate;
  1082. end;
  1083.  
  1084. procedure TIvDBLookupControl.WMSetFocus(var Message: TMessage);
  1085. begin
  1086.   FFocused := True;
  1087.   Inherited;
  1088.   Invalidate;
  1089. end;
  1090.  
  1091.  
  1092. { TIvDBLookupListBox }
  1093.  
  1094. constructor TIvDBLookupListBox.Create(owner: TComponent);
  1095. begin
  1096.   inherited Create(owner);
  1097.   ControlStyle := ControlStyle + [csDoubleClicks];
  1098.   Width := 121;
  1099.   FBorderStyle := bsSingle;
  1100.   RowCount := 7;
  1101. end;
  1102.  
  1103. procedure TIvDBLookupListBox.CreateParams(var Params: TCreateParams);
  1104. begin
  1105.   inherited CreateParams(Params);
  1106.   with Params do
  1107.     if FBorderStyle = bsSingle then
  1108.       if NewStyleControls and Ctl3D then
  1109.         ExStyle := ExStyle or WS_EX_CLIENTEDGE
  1110.       else
  1111.         Style := Style or WS_BORDER;
  1112. {$IFDEF IVPRO32}
  1113.   if IvIsLocaleBidirectional(FLocale) then
  1114.     Params.ExStyle := Params.ExStyle or WS_EX_RIGHT or WS_EX_LEFTSCROLLBAR or WS_EX_RTLREADING;
  1115. {$ENDIF}
  1116. end;
  1117.  
  1118. procedure TIvDBLookupListBox.CreateWnd;
  1119. begin
  1120.   inherited CreateWnd;
  1121.   UpdateScrollBar;
  1122. end;
  1123.  
  1124. function TIvDBLookupListBox.GetKeyIndex: Integer;
  1125. var
  1126.   FieldValue: Variant;
  1127. begin
  1128.   if not VarIsNull(FKeyValue) then
  1129.     for Result := 0 to FRecordCount - 1 do
  1130.     begin
  1131.       FListLink.ActiveRecord := Result;
  1132.       FieldValue := FKeyField.Value;
  1133.       FListLink.ActiveRecord := FRecordIndex;
  1134.       if VarEquals(FieldValue, FKeyValue) then Exit;
  1135.     end;
  1136.   Result := -1;
  1137. end;
  1138.  
  1139. procedure TIvDBLookupListBox.KeyDown(var Key: Word; Shift: TShiftState);
  1140. var
  1141.   Delta, KeyIndex: Integer;
  1142. begin
  1143.   inherited KeyDown(Key, Shift);
  1144.   if CanModify then
  1145.   begin
  1146.     Delta := 0;
  1147.     case Key of
  1148.       VK_UP, VK_LEFT: Delta := -1;
  1149.       VK_DOWN, VK_RIGHT: Delta := 1;
  1150.       VK_PRIOR: Delta := 1 - FRowCount;
  1151.       VK_NEXT: Delta := FRowCount - 1;
  1152.       VK_HOME: Delta := -Maxint;
  1153.       VK_END: Delta := Maxint;
  1154.     end;
  1155.     if Delta <> 0 then
  1156.     begin
  1157.       FSearchText := '';
  1158.       if Delta = -Maxint then FListLink.DataSet.First else
  1159.         if Delta = Maxint then FListLink.DataSet.Last else
  1160.         begin
  1161.           KeyIndex := GetKeyIndex;
  1162.           if KeyIndex >= 0 then
  1163.             FListLink.DataSet.MoveBy(KeyIndex - FRecordIndex)
  1164.           else
  1165.           begin
  1166.             KeyValueChanged;
  1167.             Delta := 0;
  1168.           end;
  1169.           FListLink.DataSet.MoveBy(Delta);
  1170.         end;
  1171.       SelectCurrent;
  1172.     end;
  1173.   end;
  1174. end;
  1175.  
  1176. procedure TIvDBLookupListBox.KeyPress(var Key: Char);
  1177. begin
  1178.   inherited KeyPress(Key);
  1179.   ProcessSearchKey(Key);
  1180. end;
  1181.  
  1182. procedure TIvDBLookupListBox.KeyValueChanged;
  1183. begin
  1184.   if FListActive and not FLockPosition then
  1185.     if not LocateKey then FListLink.DataSet.First;
  1186.   if FListField <> nil then
  1187.     FSelectedItem := FListField.DisplayText else
  1188.     FSelectedItem := '';
  1189. end;
  1190.  
  1191. procedure TIvDBLookupListBox.ListLinkActiveChanged;
  1192. begin
  1193.   try
  1194.     inherited;
  1195.   finally
  1196.     if FListActive then KeyValueChanged else ListLinkDataChanged;
  1197.   end;
  1198. end;
  1199.  
  1200. procedure TIvDBLookupListBox.ListLinkDataChanged;
  1201. begin
  1202.   if FListActive then
  1203.   begin
  1204.     FRecordIndex := FListLink.ActiveRecord;
  1205.     FRecordCount := FListLink.RecordCount;
  1206.     FKeySelected := not VarIsNull(FKeyValue) or
  1207.       not FListLink.DataSet.BOF;
  1208.   end else
  1209.   begin
  1210.     FRecordIndex := 0;
  1211.     FRecordCount := 0;
  1212.     FKeySelected := False;
  1213.   end;
  1214.   if HandleAllocated then
  1215.   begin
  1216.     UpdateScrollBar;
  1217.     Invalidate;
  1218.   end;
  1219. end;
  1220.  
  1221. procedure TIvDBLookupListBox.MouseDown(Button: TMouseButton; Shift: TShiftState;
  1222.   X, Y: Integer);
  1223. begin
  1224.   if Button = mbLeft then
  1225.   begin
  1226.     FSearchText := '';
  1227.     if not FPopup then
  1228.     begin
  1229.       SetFocus;
  1230.       if not FFocused then Exit;
  1231.     end;
  1232.     if CanModify then
  1233.       if ssDouble in Shift then
  1234.       begin
  1235.         if FRecordIndex = Y div GetTextHeight then DblClick;
  1236.       end else
  1237.       begin
  1238.         MouseCapture := True;
  1239.         FTracking := True;
  1240.         SelectItemAt(X, Y);
  1241.       end;
  1242.   end;
  1243.   inherited MouseDown(Button, Shift, X, Y);
  1244. end;
  1245.  
  1246. procedure TIvDBLookupListBox.MouseMove(Shift: TShiftState; X, Y: Integer);
  1247. begin
  1248.   if FTracking then
  1249.   begin
  1250.     SelectItemAt(X, Y);
  1251.     FMousePos := Y;
  1252.     TimerScroll;
  1253.   end;
  1254.   inherited MouseMove(Shift, X, Y);
  1255. end;
  1256.  
  1257. procedure TIvDBLookupListBox.MouseUp(Button: TMouseButton; Shift: TShiftState;
  1258.   X, Y: Integer);
  1259. begin
  1260.   if FTracking then
  1261.   begin
  1262.     StopTracking;
  1263.     SelectItemAt(X, Y);
  1264.   end;
  1265.   inherited MouseUp(Button, Shift, X, Y);
  1266. end;
  1267.  
  1268. procedure TIvDBLookupListBox.Paint;
  1269. var
  1270.   I, J, W, X, TextWidth, TextHeight, LastFieldIndex: Integer;
  1271.   S: string;
  1272.   R: TRect;
  1273.   Selected: Boolean;
  1274.   Field: TField;
  1275. begin
  1276.   Canvas.Font := Font;
  1277.   TextWidth := Canvas.TextWidth('0');
  1278.   TextHeight := Canvas.TextHeight('0');
  1279.   LastFieldIndex := FListFields.Count - 1;
  1280.   if ColorToRGB(Color) <> ColorToRGB(clBtnFace) then
  1281.     Canvas.Pen.Color := clBtnFace else
  1282.     Canvas.Pen.Color := clBtnShadow;
  1283.   for I := 0 to FRowCount - 1 do
  1284.   begin
  1285.     Canvas.Font.Color := Font.Color;
  1286.     Canvas.Brush.Color := Color;
  1287.     Selected := not FKeySelected and (I = 0);
  1288.     R.Top := I * TextHeight;
  1289.     R.Bottom := R.Top + TextHeight;
  1290.     if I < FRecordCount then
  1291.     begin
  1292.       FListLink.ActiveRecord := I;
  1293.       if not VarIsNull(FKeyValue) and
  1294.         VarEquals(FKeyField.Value, FKeyValue) then
  1295.       begin
  1296.         Canvas.Font.Color := clHighlightText;
  1297.         Canvas.Brush.Color := clHighlight;
  1298.         Selected := True;
  1299.       end;
  1300.       R.Right := 0;
  1301.       for J := 0 to LastFieldIndex do
  1302.       begin
  1303.         Field := FListFields[J];
  1304.         if J < LastFieldIndex then
  1305.           W := Field.DisplayWidth * TextWidth + 4 else
  1306.           W := ClientWidth - R.Right;
  1307.         S := Field.DisplayText;
  1308.         X := 2;
  1309.         case Field.Alignment of
  1310.           taRightJustify: X := W - Canvas.TextWidth(S) - 3;
  1311.           taCenter: X := (W - Canvas.TextWidth(S)) div 2;
  1312.         end;
  1313.         R.Left := R.Right;
  1314.         R.Right := R.Right + W;
  1315.  
  1316.         { This has been changed from the standard VCL }
  1317.  
  1318.         {Canvas.TextRect(R, R.Left + X, R.Top, S);}
  1319.         PaintItem(Canvas, S, R, X, 0);
  1320.  
  1321.         if J < LastFieldIndex then
  1322.         begin
  1323.           Canvas.MoveTo(R.Right, R.Top);
  1324.           Canvas.LineTo(R.Right, R.Bottom);
  1325.           Inc(R.Right);
  1326.           if R.Right >= ClientWidth then Break;
  1327.         end;
  1328.       end;
  1329.     end;
  1330.     R.Left := 0;
  1331.     R.Right := ClientWidth;
  1332.     if I >= FRecordCount then Canvas.FillRect(R);
  1333.     if Selected and (FFocused or FPopup) then Canvas.DrawFocusRect(R);
  1334.   end;
  1335.   if FRecordCount <> 0 then FListLink.ActiveRecord := FRecordIndex;
  1336. end;
  1337.  
  1338. procedure TIvDBLookupListBox.SelectCurrent;
  1339. begin
  1340.   FLockPosition := True;
  1341.   try
  1342.     SelectKeyValue(FKeyField.Value);
  1343.   finally
  1344.     FLockPosition := False;
  1345.   end;
  1346. end;
  1347.  
  1348. procedure TIvDBLookupListBox.SelectItemAt(X, Y: Integer);
  1349. var
  1350.   Delta: Integer;
  1351. begin
  1352.   if Y < 0 then Y := 0;
  1353.   if Y >= ClientHeight then Y := ClientHeight - 1;
  1354.   Delta := Y div GetTextHeight - FRecordIndex;
  1355.   FListLink.DataSet.MoveBy(Delta);
  1356.   SelectCurrent;
  1357. end;
  1358.  
  1359. procedure TIvDBLookupListBox.SetBorderStyle(Value: TBorderStyle);
  1360. begin
  1361.   if FBorderStyle <> Value then
  1362.   begin
  1363.     FBorderStyle := Value;
  1364.     RecreateWnd;
  1365.     RowCount := RowCount;
  1366.   end;
  1367. end;
  1368.  
  1369. procedure TIvDBLookupListBox.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  1370. var
  1371.   BorderSize, TextHeight, Rows: Integer;
  1372. begin
  1373.   BorderSize := GetBorderSize;
  1374.   TextHeight := GetTextHeight;
  1375.   Rows := (AHeight - BorderSize) div TextHeight;
  1376.   if Rows < 1 then Rows := 1;
  1377.   FRowCount := Rows;
  1378.   if FListLink.BufferCount <> Rows then
  1379.   begin
  1380.     FListLink.BufferCount := Rows;
  1381.     ListLinkDataChanged;
  1382.   end;
  1383.   inherited SetBounds(ALeft, ATop, AWidth, Rows * TextHeight + BorderSize);
  1384. end;
  1385.  
  1386. procedure TIvDBLookupListBox.SetRowCount(Value: Integer);
  1387. begin
  1388.   if Value < 1 then Value := 1;
  1389.   if Value > 100 then Value := 100;
  1390.   Height := Value * GetTextHeight + GetBorderSize;
  1391. end;
  1392.  
  1393. procedure TIvDBLookupListBox.StopTimer;
  1394. begin
  1395.   if FTimerActive then
  1396.   begin
  1397.     KillTimer(Handle, 1);
  1398.     FTimerActive := False;
  1399.   end;
  1400. end;
  1401.  
  1402. procedure TIvDBLookupListBox.StopTracking;
  1403. begin
  1404.   if FTracking then
  1405.   begin
  1406.     StopTimer;
  1407.     FTracking := False;
  1408.     MouseCapture := False;
  1409.   end;
  1410. end;
  1411.  
  1412. procedure TIvDBLookupListBox.TimerScroll;
  1413. var
  1414.   Delta, Distance, Interval: Integer;
  1415. begin
  1416.   Delta := 0;
  1417.   Distance := 0;
  1418.   if FMousePos < 0 then
  1419.   begin
  1420.     Delta := -1;
  1421.     Distance := -FMousePos;
  1422.   end;
  1423.   if FMousePos >= ClientHeight then
  1424.   begin
  1425.     Delta := 1;
  1426.     Distance := FMousePos - ClientHeight + 1;
  1427.   end;
  1428.   if Delta = 0 then StopTimer else
  1429.   begin
  1430.     if FListLink.DataSet.MoveBy(Delta) <> 0 then SelectCurrent;
  1431.     Interval := 200 - Distance * 15;
  1432.     if Interval < 0 then Interval := 0;
  1433.     SetTimer(Handle, 1, Interval, nil);
  1434.     FTimerActive := True;
  1435.   end;
  1436. end;
  1437.  
  1438. procedure TIvDBLookupListBox.UpdateScrollBar;
  1439. var
  1440.   Pos, Max: Integer;
  1441.   ScrollInfo: TScrollInfo;
  1442. begin
  1443.   Pos := 0;
  1444.   Max := 0;
  1445.   if FRecordCount = FRowCount then
  1446.   begin
  1447.     Max := 4;
  1448.     if not FListLink.DataSet.BOF then
  1449.       if not FListLink.DataSet.EOF then Pos := 2 else Pos := 4;
  1450.   end;
  1451.   ScrollInfo.cbSize := SizeOf(TScrollInfo);
  1452.   ScrollInfo.fMask := SIF_POS or SIF_RANGE;
  1453.   if not GetScrollInfo(Handle, SB_VERT, ScrollInfo) or
  1454.     (ScrollInfo.nPos <> Pos) or (ScrollInfo.nMax <> Max) then
  1455.   begin
  1456.     ScrollInfo.nMin := 0;
  1457.     ScrollInfo.nMax := Max;
  1458.     ScrollInfo.nPos := Pos;
  1459.     SetScrollInfo(Handle, SB_VERT, ScrollInfo, True);
  1460.   end;
  1461. end;
  1462.  
  1463. procedure TIvDBLookupListBox.CMCtl3DChanged(var Message: TMessage);
  1464. begin
  1465.   if NewStyleControls and (FBorderStyle = bsSingle) then
  1466.   begin
  1467.     RecreateWnd;
  1468.     RowCount := RowCount;
  1469.   end;
  1470.   inherited;
  1471. end;
  1472.  
  1473. procedure TIvDBLookupListBox.CMFontChanged(var Message: TMessage);
  1474. begin
  1475.   inherited;
  1476.   Height := Height;
  1477. end;
  1478.  
  1479. procedure TIvDBLookupListBox.WMCancelMode(var Message: TMessage);
  1480. begin
  1481.   StopTracking;
  1482.   inherited;
  1483. end;
  1484.  
  1485. procedure TIvDBLookupListBox.WMTimer(var Message: TMessage);
  1486. begin
  1487.   TimerScroll;
  1488. end;
  1489.  
  1490. procedure TIvDBLookupListBox.WMVScroll(var Message: TWMVScroll);
  1491. begin
  1492.   FSearchText := '';
  1493.   with Message, FListLink.DataSet do
  1494.     case ScrollCode of
  1495.       SB_LINEUP: MoveBy(-FRecordIndex - 1);
  1496.       SB_LINEDOWN: MoveBy(FRecordCount - FRecordIndex);
  1497.       SB_PAGEUP: MoveBy(-FRecordIndex - FRecordCount + 1);
  1498.       SB_PAGEDOWN: MoveBy(FRecordCount - FRecordIndex + FRecordCount - 2);
  1499.       SB_THUMBPOSITION:
  1500.         begin
  1501.           case Pos of
  1502.             0: First;
  1503.             1: MoveBy(-FRecordIndex - FRecordCount + 1);
  1504.             2: Exit;
  1505.             3: MoveBy(FRecordCount - FRecordIndex + FRecordCount - 2);
  1506.             4: Last;
  1507.           end;
  1508.         end;
  1509.       SB_BOTTOM: Last;
  1510.       SB_TOP: First;
  1511.     end;
  1512. end;
  1513.  
  1514.  
  1515. { TIvPopupDataList }
  1516.  
  1517. constructor TIvPopupDataList.Create(AOwner: TComponent);
  1518. begin
  1519.   inherited Create(AOwner);
  1520.   ControlStyle := ControlStyle + [csNoDesignVisible, csReplicatable];
  1521.   FPopup := True;
  1522. end;
  1523.  
  1524. procedure TIvPopupDataList.CreateParams(var Params: TCreateParams);
  1525. begin
  1526.   inherited CreateParams(Params);
  1527.   with Params do
  1528.   begin
  1529.     Style := WS_POPUP or WS_BORDER;
  1530.     ExStyle := WS_EX_TOOLWINDOW;
  1531.     WindowClass.Style := CS_SAVEBITS;
  1532.   end;
  1533. end;
  1534.  
  1535. procedure TIvPopupDataList.WMMouseActivate(var Message: TMessage);
  1536. begin
  1537.   Message.Result := MA_NOACTIVATE;
  1538. end;
  1539.  
  1540.  
  1541. { TIvDBLookupComboBox }
  1542.  
  1543. constructor TIvDBLookupComboBox.Create(AOwner: TComponent);
  1544. begin
  1545.   inherited Create(AOwner);
  1546.   ControlStyle := ControlStyle + [csReplicatable];
  1547.   Width := 145;
  1548.   Height := 0;
  1549.   FDataList := TIvPopupDataList.Create(Self);
  1550.   FDataList.Visible := False;
  1551.   FDataList.Parent := Self;
  1552.   FDataList.OnMouseUp := ListMouseUp;
  1553.   FButtonWidth := GetSystemMetrics(SM_CXVSCROLL);
  1554.   FDropDownRows := 7;
  1555. end;
  1556.  
  1557. procedure TIvDBLookupComboBox.CloseUp(Accept: Boolean);
  1558. var
  1559.   ListValue: Variant;
  1560. begin
  1561.   if FListVisible then
  1562.   begin
  1563.     if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
  1564.     ListValue := FDataList.KeyValue;
  1565.     SetWindowPos(FDataList.Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or
  1566.       SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW);
  1567.     FListVisible := False;
  1568.     FDataList.ListSource := nil;
  1569.     Invalidate;
  1570.     FSearchText := '';
  1571.     if Accept and CanModify then SelectKeyValue(ListValue);
  1572.     if Assigned(FOnCloseUp) then FOnCloseUp(Self);
  1573.   end;
  1574. end;
  1575.  
  1576. procedure TIvDBLookupComboBox.CreateParams(var Params: TCreateParams);
  1577. begin
  1578.   inherited CreateParams(Params);
  1579.   with Params do
  1580.     if NewStyleControls and Ctl3D then
  1581.       ExStyle := ExStyle or WS_EX_CLIENTEDGE
  1582.     else
  1583.       Style := Style or WS_BORDER;
  1584. {$IFDEF IVPRO32}
  1585.   if IvIsLocaleBidirectional(FLocale) then
  1586.     Params.ExStyle := Params.ExStyle or WS_EX_RIGHT or WS_EX_LEFTSCROLLBAR or WS_EX_RTLREADING;
  1587. {$ENDIF}
  1588. end;
  1589.  
  1590. procedure TIvDBLookupComboBox.DropDown;
  1591. var
  1592.   P: TPoint;
  1593.   I, Y: Integer;
  1594.   S: string;
  1595. begin
  1596.   if not FListVisible and FListActive then
  1597.   begin
  1598.     if Assigned(FOnDropDown) then FOnDropDown(Self);
  1599.     FDataList.Color := Color;
  1600.     FDataList.Font := Font;
  1601.     if FDropDownWidth > 0 then
  1602.       FDataList.Width := FDropDownWidth else
  1603.       FDataList.Width := Width;
  1604.     FDataList.ReadOnly := not CanModify;
  1605.     FDataList.RowCount := FDropDownRows;
  1606.     FDataList.KeyField := FKeyFieldName;
  1607.     for I := 0 to FListFields.Count - 1 do
  1608.       S := S + TField(FListFields[I]).FieldName + ';';
  1609.     FDataList.ListField := S;
  1610.     FDataList.ListFieldIndex := FListFields.IndexOf(FListField);
  1611.     FDataList.ListSource := FListLink.DataSource;
  1612.     FDataList.KeyValue := KeyValue;
  1613.     P := Parent.ClientToScreen(Point(Left, Top));
  1614.     Y := P.Y + Height;
  1615.     if Y + FDataList.Height > Screen.Height then Y := P.Y - FDataList.Height;
  1616.     case FDropDownAlign of
  1617.       daRight: Dec(P.X, FDataList.Width - Width);
  1618.       daCenter: Dec(P.X, (FDataList.Width - Width) div 2);
  1619.     end;
  1620.     SetWindowPos(FDataList.Handle, HWND_TOP, P.X, Y, 0, 0,
  1621.       SWP_NOSIZE or SWP_NOACTIVATE or SWP_SHOWWINDOW);
  1622.     FListVisible := True;
  1623.     Repaint;
  1624.   end;
  1625. end;
  1626.  
  1627. procedure TIvDBLookupComboBox.KeyDown(var Key: Word; Shift: TShiftState);
  1628. var
  1629.   Delta: Integer;
  1630. begin
  1631.   inherited KeyDown(Key, Shift);
  1632.   if FListActive and ((Key = VK_UP) or (Key = VK_DOWN)) then
  1633.     if ssAlt in Shift then
  1634.     begin
  1635.       if FListVisible then CloseUp(True) else DropDown;
  1636.       Key := 0;
  1637.     end else
  1638.       if not FListVisible then
  1639.       begin
  1640.         if not LocateKey then
  1641.           FListLink.DataSet.First
  1642.         else
  1643.         begin
  1644.           if Key = VK_UP then Delta := -1 else Delta := 1;
  1645.           FListLink.DataSet.MoveBy(Delta);
  1646.         end;
  1647.         SelectKeyValue(FKeyField.Value);
  1648.         Key := 0;
  1649.       end;
  1650.   if (Key <> 0) and FListVisible then FDataList.KeyDown(Key, Shift);
  1651. end;
  1652.  
  1653. procedure TIvDBLookupComboBox.KeyPress(var Key: Char);
  1654. begin
  1655.   inherited KeyPress(Key);
  1656.   if FListVisible then
  1657.     if Key in [#13, #27] then
  1658.       CloseUp(Key = #13)
  1659.     else
  1660.       FDataList.KeyPress(Key)
  1661.   else
  1662.     ProcessSearchKey(Key);
  1663. end;
  1664.  
  1665. procedure TIvDBLookupComboBox.KeyValueChanged;
  1666. begin
  1667.   if FLookupMode then
  1668.   begin
  1669.     FText := FDataField.DisplayText;
  1670.     FAlignment := FDataField.Alignment;
  1671.   end else
  1672.   if FListActive and LocateKey then
  1673.   begin
  1674.     FText := FListField.DisplayText;
  1675.     FAlignment := FListField.Alignment;
  1676.   end else
  1677.   begin
  1678.     FText := '';
  1679.     FAlignment := taLeftJustify;
  1680.   end;
  1681.   Invalidate;
  1682. end;
  1683.  
  1684. procedure TIvDBLookupComboBox.ListLinkActiveChanged;
  1685. begin
  1686.   inherited;
  1687.   KeyValueChanged;
  1688. end;
  1689.  
  1690. procedure TIvDBLookupComboBox.ListMouseUp(Sender: TObject; Button: TMouseButton;
  1691.   Shift: TShiftState; X, Y: Integer);
  1692. begin
  1693.   if Button = mbLeft then
  1694.     CloseUp(PtInRect(FDataList.ClientRect, Point(X, Y)));
  1695. end;
  1696.  
  1697. procedure TIvDBLookupComboBox.MouseDown(Button: TMouseButton; Shift: TShiftState;
  1698.   X, Y: Integer);
  1699. begin
  1700.   if Button = mbLeft then
  1701.   begin
  1702.     SetFocus;
  1703.     if not FFocused then Exit;
  1704.     if FListVisible then CloseUp(False) else
  1705.       if FListActive then
  1706.       begin
  1707.         MouseCapture := True;
  1708.         FTracking := True;
  1709.         TrackButton(X, Y);
  1710.         DropDown;
  1711.       end;
  1712.   end;
  1713.   inherited MouseDown(Button, Shift, X, Y);
  1714. end;
  1715.  
  1716. procedure TIvDBLookupComboBox.MouseMove(Shift: TShiftState; X, Y: Integer);
  1717. var
  1718.   ListPos: TPoint;
  1719.   MousePos: TSmallPoint;
  1720. begin
  1721.   if FTracking then
  1722.   begin
  1723.     TrackButton(X, Y);
  1724.     if FListVisible then
  1725.     begin
  1726.       ListPos := FDataList.ScreenToClient(ClientToScreen(Point(X, Y)));
  1727.       if PtInRect(FDataList.ClientRect, ListPos) then
  1728.       begin
  1729.         StopTracking;
  1730.         MousePos := PointToSmallPoint(ListPos);
  1731.         SendMessage(FDataList.Handle, WM_LBUTTONDOWN, 0, Integer(MousePos));
  1732.         Exit;
  1733.       end;
  1734.     end;
  1735.   end;
  1736.   inherited MouseMove(Shift, X, Y);
  1737. end;
  1738.  
  1739. procedure TIvDBLookupComboBox.MouseUp(Button: TMouseButton; Shift: TShiftState;
  1740.   X, Y: Integer);
  1741. begin
  1742.   StopTracking;
  1743.   inherited MouseUp(Button, Shift, X, Y);
  1744. end;
  1745.  
  1746. procedure TIvDBLookupComboBox.Paint;
  1747. var
  1748.   W, X, Flags: Integer;
  1749.   Text: string;
  1750.   Alignment: TAlignment;
  1751.   Selected: Boolean;
  1752.   R: TRect;
  1753. begin
  1754.   Canvas.Font := Font;
  1755.   Canvas.Brush.Color := Color;
  1756.   Selected := FFocused and not FListVisible and
  1757.     not (csPaintCopy in ControlState);
  1758.   if Selected then
  1759.   begin
  1760.     Canvas.Font.Color := clHighlightText;
  1761.     Canvas.Brush.Color := clHighlight;
  1762.   end;
  1763.   if (csPaintCopy in ControlState) and (FDataField <> nil) then
  1764.   begin
  1765.     Text := FDataField.DisplayText;
  1766.     Alignment := FDataField.Alignment;
  1767.   end else
  1768.   begin
  1769.     Text := FText;
  1770.     Alignment := FAlignment;
  1771.   end;
  1772.   W := ClientWidth - FButtonWidth;
  1773.   X := 2;
  1774.   case Alignment of
  1775.     taRightJustify: X := W - Canvas.TextWidth(Text) - 3;
  1776.     taCenter: X := (W - Canvas.TextWidth(Text)) div 2;
  1777.   end;
  1778.   SetRect(R, 1, 1, W - 1, ClientHeight - 1);
  1779.  
  1780.   { This has been changed from the standard VCL }
  1781.  
  1782.   {Canvas.TextRect(R, X, 2, Text);}
  1783.   PaintItem(Canvas, Text, R, X - 1, 1);
  1784.  
  1785.   if Selected then Canvas.DrawFocusRect(R);
  1786.   SetRect(R, W, 0, ClientWidth, ClientHeight);
  1787.   if not FListActive then
  1788.     Flags := DFCS_SCROLLCOMBOBOX or DFCS_INACTIVE
  1789.   else if FPressed then
  1790.     Flags := DFCS_SCROLLCOMBOBOX or DFCS_FLAT or DFCS_PUSHED
  1791.   else
  1792.     Flags := DFCS_SCROLLCOMBOBOX;
  1793.   DrawFrameControl(Canvas.Handle, R, DFC_SCROLL, Flags);
  1794. end;
  1795.  
  1796. procedure TIvDBLookupComboBox.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  1797. begin
  1798.   inherited SetBounds(ALeft, ATop, AWidth, GetTextHeight + GetBorderSize + 4);
  1799. end;
  1800.  
  1801. procedure TIvDBLookupComboBox.StopTracking;
  1802. begin
  1803.   if FTracking then
  1804.   begin
  1805.     TrackButton(-1, -1);
  1806.     FTracking := False;
  1807.     MouseCapture := False;
  1808.   end;
  1809. end;
  1810.  
  1811. procedure TIvDBLookupComboBox.TrackButton(X, Y: Integer);
  1812. var
  1813.   NewState: Boolean;
  1814. begin
  1815.   NewState := PtInRect(Rect(ClientWidth - FButtonWidth, 0, ClientWidth,
  1816.     ClientHeight), Point(X, Y));
  1817.   if FPressed <> NewState then
  1818.   begin
  1819.     FPressed := NewState;
  1820.     Repaint;
  1821.   end;
  1822. end;
  1823.  
  1824. procedure TIvDBLookupComboBox.CMCancelMode(var Message: TCMCancelMode);
  1825. begin
  1826.   if (Message.Sender <> Self) and (Message.Sender <> FDataList) then
  1827.     CloseUp(False);
  1828. end;
  1829.  
  1830. procedure TIvDBLookupComboBox.CMCtl3DChanged(var Message: TMessage);
  1831. begin
  1832.   if NewStyleControls then
  1833.   begin
  1834.     RecreateWnd;
  1835.     Height := 0;
  1836.   end;
  1837.   inherited;
  1838. end;
  1839.  
  1840. procedure TIvDBLookupComboBox.CMFontChanged(var Message: TMessage);
  1841. begin
  1842.   inherited;
  1843.   Height := 0;
  1844. end;
  1845.  
  1846. procedure TIvDBLookupComboBox.CMGetDataLink(var Message: TMessage);
  1847. begin
  1848.   Message.Result := Integer(FDataLink);
  1849. end;
  1850.  
  1851. procedure TIvDBLookupComboBox.WMCancelMode(var Message: TMessage);
  1852. begin
  1853.   StopTracking;
  1854.   inherited;
  1855. end;
  1856.  
  1857. procedure TIvDBLookupComboBox.WMKillFocus(var Message: TWMKillFocus);
  1858. begin
  1859.   inherited;
  1860.   CloseUp(False);
  1861. end;
  1862. {$ENDIF}
  1863. {$ENDIF}
  1864.  
  1865. end.
  1866.